home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / tm / tm-view.el.z / tm-view.el
Encoding:
Text File  |  1998-05-21  |  33.3 KB  |  1,212 lines
  1. ;;; tm-view.el --- interactive MIME viewer for GNU Emacs
  2.  
  3. ;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
  4.  
  5. ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
  6. ;; Created: 1994/7/13 (1994/8/31 obsolete tm-body.el)
  7. ;; Version: $Revision: 7.83 $
  8. ;; Keywords: mail, news, MIME, multimedia
  9.  
  10. ;; This file is part of tm (Tools for MIME).
  11.  
  12. ;; This program is free software; you can redistribute it and/or
  13. ;; modify it under the terms of the GNU General Public License as
  14. ;; published by the Free Software Foundation; either version 2, or (at
  15. ;; your option) any later version.
  16.  
  17. ;; This program is distributed in the hope that it will be useful, but
  18. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20. ;; General Public License for more details.
  21.  
  22. ;; You should have received a copy of the GNU General Public License
  23. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25. ;; Boston, MA 02111-1307, USA.
  26.  
  27. ;;; Code:
  28.  
  29. (require 'tl-str)
  30. (require 'tl-list)
  31. (require 'tl-atype)
  32. (require 'tl-misc)
  33. (require 'std11)
  34. (require 'mel)
  35. (require 'tm-ew-d)
  36. (require 'tm-def)
  37. (require 'tm-parse)
  38. (require 'tm-text)
  39.  
  40.  
  41. ;;; @ version
  42. ;;;
  43.  
  44. (defconst mime-viewer/RCS-ID
  45.   "$Id: tm-view.el,v 7.83 1997/05/27 03:01:50 morioka Exp $")
  46.  
  47. (defconst mime-viewer/version (get-version-string mime-viewer/RCS-ID))
  48. (defconst mime/viewer-version mime-viewer/version)
  49.  
  50.  
  51. ;;; @ variables
  52. ;;;
  53.  
  54. (defvar mime/content-decoding-condition
  55.   '(((type . "text/plain")
  56.      (method "tm-plain" nil 'file 'type 'encoding 'mode 'name)
  57.      (mode "play" "print")
  58.      )
  59.     ((type . "text/html")
  60.      (method "tm-html" nil 'file 'type 'encoding 'mode 'name)
  61.      (mode . "play")
  62.      )
  63.     ((type . "text/x-rot13-47")
  64.      (method . mime-article/decode-caesar)
  65.      (mode . "play")
  66.      )
  67.     ((type . "audio/basic")
  68.      (method "tm-au"    nil 'file 'type 'encoding 'mode 'name)
  69.      (mode . "play")
  70.      )
  71.     
  72.     ((type . "image/jpeg")
  73.      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  74.      (mode "play" "print")
  75.      )
  76.     ((type . "image/gif")
  77.      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  78.      (mode "play" "print")
  79.      )
  80.     ((type . "image/png")
  81.      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  82.      (mode "play" "print")
  83.      )
  84.     ((type . "image/tiff")
  85.      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  86.      (mode "play" "print")
  87.      )
  88.     ((type . "image/x-tiff")
  89.      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  90.      (mode "play" "print")
  91.      )
  92.     ((type . "image/x-xbm")
  93.      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  94.      (mode "play" "print")
  95.      )
  96.     ((type . "image/x-pic")
  97.      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  98.      (mode "play" "print")
  99.      )
  100.     ((type . "image/x-mag")
  101.      (method "tm-image" nil 'file 'type 'encoding 'mode 'name)
  102.      (mode "play" "print")
  103.      )
  104.     
  105.     ((type . "video/mpeg")
  106.      (method "tm-mpeg"  nil 'file 'type 'encoding 'mode 'name)
  107.      (mode . "play")
  108.      )
  109.     
  110.     ((type . "application/postscript")
  111.      (method "tm-ps" nil 'file 'type 'encoding 'mode 'name)
  112.      (mode "play" "print")
  113.      )
  114.     ((type . "application/octet-stream")
  115.      (method "tm-file"  nil 'file 'type 'encoding 'mode 'name)
  116.      (mode "play" "print")
  117.      )
  118.     
  119.     ;;((type . "message/external-body")
  120.     ;; (method "xterm" nil
  121.     ;;           "-e" "showexternal"
  122.     ;;         'file '"access-type" '"name" '"site" '"directory"))
  123.     ((type . "message/rfc822")
  124.      (method . mime-article/view-message/rfc822)
  125.      (mode . "play")
  126.      )
  127.     ((type . "message/partial")
  128.      (method . mime-article/decode-message/partial)
  129.      (mode . "play")
  130.      )
  131.     
  132.     ((method "metamail" t "-m" "tm" "-x" "-d" "-z" "-e" 'file)
  133.      (mode . "play")
  134.      )
  135.     ((method "tm-file"  nil 'file 'type 'encoding 'mode 'name)
  136.      (mode . "extract")
  137.      )
  138.     ))
  139.  
  140. (defvar mime-viewer/childrens-header-showing-Content-Type-list
  141.   '("message/rfc822" "message/news"))
  142.  
  143. (defvar mime-viewer/default-showing-Content-Type-list
  144.   '("text/plain" nil "text/richtext" "text/enriched"
  145.     "text/x-latex" "application/x-latex"
  146.     "message/delivery-status"
  147.     "application/pgp" "text/x-pgp"
  148.     "application/octet-stream"
  149.     "application/x-selection" "application/x-comment"))
  150.  
  151. (defvar mime-viewer/content-button-ignored-ctype-list
  152.   '("application/x-selection"))
  153.  
  154. (defvar mime-viewer/content-button-visible-ctype-list
  155.   '("application/pgp"))
  156.  
  157. (defvar mime-viewer/uuencode-encoding-name-list '("x-uue" "x-uuencode"))
  158.  
  159. (defvar mime-viewer/ignored-field-list
  160.   '(".*Received" ".*Path" ".*Id" "References"
  161.     "Replied" "Errors-To"
  162.     "Lines" "Sender" ".*Host" "Xref"
  163.     "Content-Type" "Precedence"
  164.     "Status" "X-VM-.*")
  165.   "All fields that match this list will be hidden in MIME preview buffer.
  166. Each elements are regexp of field-name. [tm-view.el]")
  167.  
  168. (defvar mime-viewer/ignored-field-regexp
  169.   (concat "^"
  170.       (apply (function regexp-or) mime-viewer/ignored-field-list)
  171.       ":"))
  172.  
  173. (defvar mime-viewer/visible-field-list
  174.   '("Dnas.*" "Message-Id")
  175.   "All fields that match this list will be displayed in MIME preview buffer.
  176. Each elements are regexp of field-name. [tm-view.el]")
  177.  
  178. (defvar mime-viewer/visible-field-regexp
  179.   (concat "^"
  180.       (apply (function regexp-or) mime-viewer/visible-field-list)
  181.       ":"))
  182.  
  183. (defvar mime-viewer/redisplay nil)
  184.  
  185. (defvar mime-viewer/announcement-for-message/partial
  186.   (if (and (>= emacs-major-version 19) window-system)
  187.       "\
  188. \[[ This is message/partial style split message. ]]
  189. \[[ Please press `v' key in this buffer          ]]
  190. \[[ or click here by mouse button-2.             ]]"
  191.     "\
  192. \[[ This is message/partial style split message. ]]
  193. \[[ Please press `v' key in this buffer.         ]]"
  194.     ))
  195.  
  196.  
  197. ;;; @@ predicate functions
  198. ;;;
  199.  
  200. (defun mime-viewer/header-visible-p (rcnum cinfo &optional ctype)
  201.   (or (null rcnum)
  202.       (progn
  203.     (setq ctype
  204.           (mime::content-info/type
  205.            (mime-article/rcnum-to-cinfo (cdr rcnum) cinfo)
  206.            ))
  207.     (member ctype mime-viewer/childrens-header-showing-Content-Type-list)
  208.     )))
  209.  
  210. (defun mime-viewer/body-visible-p (rcnum cinfo &optional ctype)
  211.   (let (ccinfo)
  212.     (or ctype
  213.     (setq ctype
  214.           (mime::content-info/type
  215.            (setq ccinfo (mime-article/rcnum-to-cinfo rcnum cinfo))
  216.            ))
  217.     )
  218.     (and (member ctype mime-viewer/default-showing-Content-Type-list)
  219.      (if (string-equal ctype "application/octet-stream")
  220.          (progn
  221.            (or ccinfo
  222.            (setq ccinfo (mime-article/rcnum-to-cinfo rcnum cinfo))
  223.            )
  224.            (member (mime::content-info/encoding ccinfo)
  225.                '(nil "7bit" "8bit"))
  226.            )
  227.        t))
  228.     ))
  229.  
  230.  
  231. ;;; @@ content button
  232. ;;;
  233.  
  234. (defun mime-preview/insert-content-button
  235.   (rcnum cinfo ctype params subj encoding)
  236.   (save-restriction
  237.     (narrow-to-region (point)(point))
  238.     (let ((access-type (assoc "access-type" params))
  239.       (charset (assoc "charset" params))
  240.       (num (or (assoc-value "x-part-number" params)
  241.            (if (consp rcnum)
  242.                (mapconcat (function
  243.                    (lambda (num)
  244.                      (format "%s" (1+ num))
  245.                      ))
  246.                   (reverse rcnum) ".")
  247.              "0"))
  248.            ))
  249.       (cond (access-type
  250.          (let ((server (assoc "server" params)))
  251.            (setq access-type (cdr access-type))
  252.            (if server
  253.            (insert (format "[%s %s ([%s] %s)]\n" num subj
  254.                    access-type (cdr server)))
  255.          (let ((site (assoc-value "site" params))
  256.                (dir (assoc-value "directory" params))
  257.                )
  258.            (insert (format "[%s %s ([%s] %s:%s)]\n" num subj
  259.                    access-type site dir))
  260.            )))
  261.          )
  262.         (t
  263.          (insert (concat "[" num " " subj))
  264.          (let ((rest
  265.             (if (setq charset (cdr charset))
  266.             (if encoding
  267.                 (format " <%s; %s (%s)>]\n"
  268.                     ctype charset encoding)
  269.               (format " <%s; %s>]\n" ctype charset)
  270.               )
  271.               (format " <%s>]\n" ctype)
  272.               )))
  273.            (if (>= (+ (current-column)(length rest))(window-width))
  274.            (setq rest (concat "\n\t" rest))
  275.          )
  276.            (insert rest)
  277.            ))))
  278.     (tm:add-button (point-min)(1- (point-max))
  279.            (function mime-viewer/play-content))
  280.     ))
  281.  
  282. (defun mime-preview/default-content-button-function
  283.   (rcnum cinfo ctype params subj encoding)
  284.   (if (and (consp rcnum)
  285.        (not (member
  286.          ctype
  287.          mime-viewer/content-button-ignored-ctype-list)))
  288.       (mime-preview/insert-content-button
  289.        rcnum cinfo ctype params subj encoding)
  290.     ))
  291.  
  292. (defvar mime-preview/content-button-function
  293.   (function mime-preview/default-content-button-function))
  294.  
  295.  
  296. ;;; @@ content header filter
  297. ;;;
  298.  
  299. (defun mime-preview/cut-header ()
  300.   (goto-char (point-min))
  301.   (while (and
  302.       (re-search-forward mime-viewer/ignored-field-regexp nil t)
  303.       (let* ((beg (match-beginning 0))
  304.          (end (match-end 0))
  305.          (name (buffer-substring beg end))
  306.          )
  307.         (if (not (string-match mime-viewer/visible-field-regexp name))
  308.         (delete-region
  309.          beg
  310.          (save-excursion
  311.            (and
  312.             (re-search-forward "^\\([^ \t]\\|$\\)" nil t)
  313.             (match-beginning 0)
  314.             )))
  315.           )
  316.         t)))
  317.   )
  318.  
  319. (defun mime-viewer/default-content-header-filter ()
  320.   (mime-preview/cut-header)
  321.   (mime/decode-message-header)
  322.   )
  323.  
  324. (defvar mime-viewer/content-header-filter-alist nil)
  325.  
  326.  
  327. ;;; @@ content filter
  328. ;;;
  329.  
  330. (defvar mime-viewer/content-filter-alist
  331.   '(("text/enriched" . mime-preview/filter-for-text/enriched)
  332.     ("text/richtext" . mime-preview/filter-for-text/richtext)
  333.     (t . mime-preview/filter-for-text/plain)
  334.     ))
  335.  
  336.  
  337. ;;; @@ content separator
  338. ;;;
  339.  
  340. (defun mime-preview/default-content-separator (rcnum cinfo ctype params subj)
  341.   (if (and (not (mime-viewer/header-visible-p rcnum cinfo ctype))
  342.        (not (mime-viewer/body-visible-p rcnum cinfo ctype))
  343.        )
  344.       (progn
  345.     (goto-char (point-max))
  346.     (insert "\n")
  347.     )))
  348.  
  349.  
  350. ;;; @@ buffer local variables
  351. ;;;
  352.  
  353. ;; for XEmacs
  354. (defvar mime::article/preview-buffer nil)
  355. (defvar mime::article/code-converter nil)
  356. (defvar mime::preview/article-buffer nil)
  357.  
  358. (make-variable-buffer-local 'mime::article/content-info)
  359. (make-variable-buffer-local 'mime::article/preview-buffer)
  360. (make-variable-buffer-local 'mime::article/code-converter)
  361.  
  362. (make-variable-buffer-local 'mime::preview/mother-buffer)
  363. (make-variable-buffer-local 'mime::preview/content-list)
  364. (make-variable-buffer-local 'mime::preview/article-buffer)
  365. (make-variable-buffer-local 'mime::preview/original-major-mode)
  366. (make-variable-buffer-local 'mime::preview/original-window-configuration)
  367.  
  368.  
  369. ;;; @@ quitting method
  370. ;;;
  371.  
  372. (defvar mime-viewer/quitting-method-alist
  373.   '((mime/show-message-mode
  374.      . mime-viewer/quitting-method-for-mime/show-message-mode)))
  375.  
  376. (defvar mime-viewer/over-to-previous-method-alist nil)
  377. (defvar mime-viewer/over-to-next-method-alist nil)
  378.  
  379. (defvar mime-viewer/show-summary-method nil)
  380.  
  381.  
  382. ;;; @@ following method
  383. ;;;
  384.  
  385. (defvar mime-viewer/following-method-alist nil)
  386.  
  387. (defvar mime-viewer/following-required-fields-list
  388.   '("From"))
  389.  
  390.  
  391. ;;; @@ X-Face
  392. ;;;
  393.  
  394. ;; hack from Gnus 5.0.4.
  395.  
  396. (defvar mime-viewer/x-face-to-pbm-command
  397.   "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm")
  398.  
  399. (defvar mime-viewer/x-face-command
  400.   (concat mime-viewer/x-face-to-pbm-command
  401.       " | xv -quit -")
  402.   "String to be executed to display an X-Face field.
  403. The command will be executed in a sub-shell asynchronously.
  404. The compressed face will be piped to this command.")
  405.  
  406. (defun mime-viewer/x-face-function ()
  407.   "Function to display X-Face field. You can redefine to customize."
  408.   ;; 1995/10/12 (c.f. tm-eng:130)
  409.   ;;    fixed by Eric Ding <ericding@San-Jose.ate.slb.com>
  410.   (save-restriction
  411.     (narrow-to-region (point-min) (re-search-forward "^$" nil t))
  412.     ;; end
  413.     (goto-char (point-min))
  414.     (if (re-search-forward "^X-Face:[ \t]*" nil t)
  415.     (let ((beg (match-end 0))
  416.           (end (std11-field-end))
  417.           )
  418.       (call-process-region beg end "sh" nil 0 nil
  419.                    "-c" mime-viewer/x-face-command)
  420.       ))))
  421.  
  422.  
  423. ;;; @@ utility
  424. ;;;
  425.  
  426. (defun mime-preview/get-original-major-mode ()
  427.   (if mime::preview/mother-buffer
  428.       (save-excursion
  429.     (set-buffer mime::preview/mother-buffer)
  430.     (mime-preview/get-original-major-mode)
  431.     )
  432.     mime::preview/original-major-mode))
  433.  
  434.  
  435. ;;; @ data structures
  436. ;;;
  437.  
  438. ;;; @@ preview-content-info
  439. ;;;
  440.  
  441. (define-structure mime::preview-content-info
  442.   point-min point-max buffer content-info)
  443.  
  444.  
  445. ;;; @ buffer setup
  446. ;;;
  447.  
  448. (defun mime-viewer/setup-buffer (&optional ctl encoding ibuf obuf)
  449.   (if ibuf
  450.       (progn
  451.     (get-buffer ibuf)
  452.     (set-buffer ibuf)
  453.     ))
  454.   (or mime-viewer/redisplay
  455.       (setq mime::article/content-info (mime/parse-message ctl encoding))
  456.       )
  457.   (let ((ret (mime-viewer/make-preview-buffer obuf)))
  458.     (setq mime::article/preview-buffer (car ret))
  459.     ret))
  460.  
  461. (defun mime-viewer/make-preview-buffer (&optional obuf)
  462.   (let* ((cinfo mime::article/content-info)
  463.      (pcl (mime/flatten-content-info cinfo))
  464.      (dest (make-list (length pcl) nil))
  465.      (the-buf (current-buffer))
  466.      (mode major-mode)
  467.      )
  468.     (or obuf
  469.     (setq obuf (concat "*Preview-" (buffer-name the-buf) "*")))
  470.     (set-buffer (get-buffer-create obuf))
  471.     (setq buffer-read-only nil)
  472.     (widen)
  473.     (erase-buffer)
  474.     (setq mime::preview/article-buffer the-buf)
  475.     (setq mime::preview/original-major-mode mode)
  476.     (setq major-mode 'mime/viewer-mode)
  477.     (setq mode-name "MIME-View")
  478.     (let ((drest dest))
  479.       (while pcl
  480.     (setcar drest
  481.         (mime-preview/display-content (car pcl) cinfo the-buf obuf))
  482.     (setq pcl (cdr pcl)
  483.           drest (cdr drest))
  484.     ))
  485.     (set-buffer-modified-p nil)
  486.     (setq buffer-read-only t)
  487.     (set-buffer the-buf)
  488.     (list obuf dest)
  489.     ))
  490.  
  491. (defun mime-preview/display-content (content cinfo ibuf obuf)
  492.   (let* ((beg (mime::content-info/point-min content))
  493.      (end (mime::content-info/point-max content))
  494.      (ctype (mime::content-info/type content))
  495.      (params (mime::content-info/parameters content))
  496.      (encoding (mime::content-info/encoding content))
  497.      (rcnum (mime::content-info/rcnum content))
  498.      he e nb ne subj)
  499.     (set-buffer ibuf)
  500.     (goto-char beg)
  501.     (setq he (if (re-search-forward "^$" nil t)
  502.          (1+ (match-end 0))
  503.            end))
  504.     (if (> he end)
  505.     (setq he end)
  506.       )
  507.     (save-restriction
  508.       (narrow-to-region beg end)
  509.       (setq subj
  510.         (mime-eword/decode-string
  511.          (mime-article/get-subject params encoding)))
  512.       )
  513.     (set-buffer obuf)
  514.     (setq nb (point))
  515.     (narrow-to-region nb nb)
  516.     (funcall mime-preview/content-button-function
  517.          rcnum cinfo ctype params subj encoding)
  518.     (if (mime-viewer/header-visible-p rcnum cinfo ctype)
  519.     (mime-preview/display-header beg he)
  520.       )
  521.     (if (and (null rcnum)
  522.          (member
  523.           ctype mime-viewer/content-button-visible-ctype-list))
  524.     (save-excursion
  525.       (goto-char (point-max))
  526.       (mime-preview/insert-content-button
  527.        rcnum cinfo ctype params subj encoding)
  528.       ))
  529.     (cond ((mime-viewer/body-visible-p rcnum cinfo ctype)
  530.        (mime-preview/display-body he end
  531.                       rcnum cinfo ctype params subj encoding)
  532.        )
  533.       ((equal ctype "message/partial")
  534.        (mime-preview/display-message/partial)
  535.        )
  536.       ((and (null rcnum)
  537.         (null (mime::content-info/children cinfo))
  538.         )
  539.        (goto-char (point-max))
  540.        (mime-preview/insert-content-button
  541.         rcnum cinfo ctype params subj encoding)
  542.        ))
  543.     (mime-preview/default-content-separator rcnum cinfo ctype params subj)
  544.     (prog1
  545.     (progn
  546.       (setq ne (point-max))
  547.       (widen)
  548.       (mime::preview-content-info/create nb (1- ne) ibuf content)
  549.       )
  550.       (goto-char ne)
  551.       )))
  552.  
  553. (defun mime-preview/display-header (beg end)
  554.   (save-restriction
  555.     (narrow-to-region (point)(point))
  556.     (insert-buffer-substring mime::preview/article-buffer beg end)
  557.     (let ((f (cdr (assq mime::preview/original-major-mode
  558.             mime-viewer/content-header-filter-alist))))
  559.       (if (functionp f)
  560.       (funcall f)
  561.     (mime-viewer/default-content-header-filter)
  562.     ))
  563.     (run-hooks 'mime-viewer/content-header-filter-hook)
  564.     ))
  565.  
  566. (defun mime-preview/display-body (beg end
  567.                       rcnum cinfo ctype params subj encoding)
  568.   (save-restriction
  569.     (narrow-to-region (point-max)(point-max))
  570.     (insert-buffer-substring mime::preview/article-buffer beg end)
  571.     (let ((f (cdr (or (assoc ctype mime-viewer/content-filter-alist)
  572.               (assq t mime-viewer/content-filter-alist)))))
  573.       (and (functionp f)
  574.        (funcall f ctype params encoding)
  575.        )
  576.       )))
  577.  
  578. (defun mime-preview/display-message/partial ()
  579.   (save-restriction
  580.     (goto-char (point-max))
  581.     (if (not (search-backward "\n\n" nil t))
  582.     (insert "\n")
  583.       )
  584.     (let ((be (point-max)))
  585.       (narrow-to-region be be)
  586.       (insert mime-viewer/announcement-for-message/partial)
  587.       (tm:add-button (point-min)(point-max)
  588.              (function mime-viewer/play-content))
  589.       )))
  590.  
  591. (defun mime-article/get-uu-filename (param &optional encoding)
  592.   (if (member (or encoding
  593.           (cdr (assq 'encoding param))
  594.           )
  595.           mime-viewer/uuencode-encoding-name-list)
  596.       (save-excursion
  597.     (or (if (re-search-forward "^begin [0-9]+ " nil t)
  598.         (if (looking-at ".+$")
  599.             (buffer-substring (match-beginning 0)(match-end 0))
  600.           ))
  601.         ""))
  602.     ))
  603.  
  604. (defun mime-article/get-subject (param &optional encoding)
  605.   (or (std11-find-field-body '("Content-Description" "Subject"))
  606.       (let (ret)
  607.     (if (or (and (setq ret (mime/Content-Disposition))
  608.              (setq ret (assoc "filename" (cdr ret)))
  609.              )
  610.         (setq ret (assoc "name" param))
  611.         (setq ret (assoc "x-name" param))
  612.         )
  613.         (std11-strip-quoted-string (cdr ret))
  614.       ))
  615.       (mime-article/get-uu-filename param encoding)
  616.       ""))
  617.  
  618.  
  619. ;;; @ content information
  620. ;;;
  621.  
  622. (defun mime-article/point-content-number (p &optional cinfo)
  623.   (or cinfo
  624.       (setq cinfo mime::article/content-info)
  625.       )
  626.   (let ((b (mime::content-info/point-min cinfo))
  627.     (e (mime::content-info/point-max cinfo))
  628.     (c (mime::content-info/children cinfo))
  629.     )
  630.     (if (and (<= b p)(<= p e))
  631.     (or (let (co ret (sn 0))
  632.           (catch 'tag
  633.         (while c
  634.           (setq co (car c))
  635.           (setq ret (mime-article/point-content-number p co))
  636.           (cond ((eq ret t) (throw 'tag (list sn)))
  637.             (ret (throw 'tag (cons sn ret)))
  638.             )
  639.           (setq c (cdr c))
  640.           (setq sn (1+ sn))
  641.           )))
  642.         t))))
  643.  
  644. (defun mime-article/rcnum-to-cinfo (rcnum &optional cinfo)
  645.   (or cinfo
  646.       (setq cinfo mime::article/content-info)
  647.       )
  648.   (find-if (function
  649.         (lambda (ci)
  650.           (equal (mime::content-info/rcnum ci) rcnum)
  651.           ))
  652.        (mime/flatten-content-info cinfo)
  653.        ))
  654.  
  655. (defun mime-article/cnum-to-cinfo (cn &optional cinfo)
  656.   (or cinfo
  657.       (setq cinfo mime::article/content-info)
  658.       )
  659.   (if (eq cn t)
  660.       cinfo
  661.     (let ((sn (car cn)))
  662.       (if (null sn)
  663.       cinfo
  664.     (let ((rc (nth sn (mime::content-info/children cinfo))))
  665.       (if rc
  666.           (mime-article/cnum-to-cinfo (cdr cn) rc)
  667.         ))
  668.     ))))
  669.  
  670. (defun mime/flatten-content-info (&optional cinfo)
  671.   (or cinfo
  672.       (setq cinfo mime::article/content-info)
  673.       )
  674.   (let ((dest (list cinfo))
  675.     (rcl (mime::content-info/children cinfo))
  676.     )
  677.     (while rcl
  678.       (setq dest (nconc dest (mime/flatten-content-info (car rcl))))
  679.       (setq rcl (cdr rcl))
  680.       )
  681.     dest))
  682.  
  683. (defun mime-preview/point-pcinfo (p &optional pcl)
  684.   (or pcl
  685.       (setq pcl mime::preview/content-list)
  686.       )
  687.   (catch 'tag
  688.     (let ((r pcl) cell)
  689.       (while r
  690.     (setq cell (car r))
  691.     (if (and (<= (mime::preview-content-info/point-min cell) p)
  692.          (<= p (mime::preview-content-info/point-max cell))
  693.          )
  694.         (throw 'tag cell)
  695.       )
  696.     (setq r (cdr r))
  697.     ))
  698.     (car (last pcl))
  699.     ))
  700.  
  701.  
  702. ;;; @ MIME viewer mode
  703. ;;;
  704.  
  705. (defconst mime-viewer/menu-title "MIME-View")
  706. (defconst mime-viewer/menu-list
  707.   '((up         "Move to upper content"      mime-viewer/up-content)
  708.     (previous     "Move to previous content"   mime-viewer/previous-content)
  709.     (next     "Move to next content"          mime-viewer/next-content)
  710.     (scroll-down "Scroll to previous content" mime-viewer/scroll-down-content)
  711.     (scroll-up     "Scroll to next content"     mime-viewer/scroll-up-content)
  712.     (play     "Play Content"               mime-viewer/play-content)
  713.     (extract     "Extract Content"            mime-viewer/extract-content)
  714.     (print     "Print"                      mime-viewer/print-content)
  715.     (x-face     "Show X Face"                mime-viewer/display-x-face)
  716.     )
  717.   "Menu for MIME Viewer")
  718.  
  719. (if running-xemacs
  720.     (progn
  721.       (defvar mime-viewer/xemacs-popup-menu
  722.     (cons mime-viewer/menu-title
  723.           (mapcar (function
  724.                (lambda (item)
  725.              (vector (nth 1 item)(nth 2 item) t)
  726.              ))
  727.               mime-viewer/menu-list)))
  728.       (defun mime-viewer/xemacs-popup-menu (event)
  729.     "Popup the menu in the MIME Viewer buffer"
  730.     (interactive "e")
  731.     (select-window (event-window event))
  732.     (set-buffer (event-buffer event))
  733.     (popup-menu 'mime-viewer/xemacs-popup-menu))
  734.       ))
  735.  
  736. (defun mime-viewer/define-keymap (&optional mother)
  737.   (let ((mime/viewer-mode-map (if mother
  738.                   (copy-keymap mother)
  739.                 (make-keymap)
  740.                 )))
  741.     (or mother
  742.     (suppress-keymap mime/viewer-mode-map))
  743.     (define-key mime/viewer-mode-map
  744.       "u"        (function mime-viewer/up-content))
  745.     (define-key mime/viewer-mode-map
  746.       "p"        (function mime-viewer/previous-content))
  747.     (define-key mime/viewer-mode-map
  748.       "n"        (function mime-viewer/next-content))
  749.     (define-key mime/viewer-mode-map
  750.       "\e\t"     (function mime-viewer/previous-content))
  751.     (define-key mime/viewer-mode-map
  752.       "\t"       (function mime-viewer/next-content))
  753.     (define-key mime/viewer-mode-map
  754.       " "        (function mime-viewer/scroll-up-content))
  755.     (define-key mime/viewer-mode-map
  756.       "\M- "     (function mime-viewer/scroll-down-content))
  757.     (define-key mime/viewer-mode-map
  758.       "\177"     (function mime-viewer/scroll-down-content))
  759.     (define-key mime/viewer-mode-map
  760.       "\C-m"     (function mime-viewer/next-line-content))
  761.     (define-key mime/viewer-mode-map
  762.       "\C-\M-m"  (function mime-viewer/previous-line-content))
  763.     (define-key mime/viewer-mode-map
  764.       "v"        (function mime-viewer/play-content))
  765.     (define-key mime/viewer-mode-map
  766.       "e"        (function mime-viewer/extract-content))
  767.     (define-key mime/viewer-mode-map
  768.       "\C-c\C-p" (function mime-viewer/print-content))
  769.     (define-key mime/viewer-mode-map
  770.       "x"        (function mime-viewer/display-x-face))
  771.     (define-key mime/viewer-mode-map
  772.       "a"        (function mime-viewer/follow-content))
  773.     (define-key mime/viewer-mode-map
  774.       "q"        (function mime-viewer/quit))
  775.     (define-key mime/viewer-mode-map
  776.       "h"        (function mime-viewer/show-summary))
  777.     (define-key mime/viewer-mode-map
  778.       "\C-c\C-x" (function mime-viewer/kill-buffer))
  779.     (define-key mime/viewer-mode-map
  780.       "<"        (function beginning-of-buffer))
  781.     (define-key mime/viewer-mode-map
  782.       ">"        (function end-of-buffer))
  783.     (define-key mime/viewer-mode-map
  784.       "?"        (function describe-mode))
  785.     (if mouse-button-2
  786.     (define-key mime/viewer-mode-map
  787.       mouse-button-2 (function tm:button-dispatcher))
  788.       )
  789.     (cond (running-xemacs
  790.        (define-key mime/viewer-mode-map
  791.          mouse-button-3 (function mime-viewer/xemacs-popup-menu))
  792.        )
  793.       ((>= emacs-major-version 19)
  794.        (define-key mime/viewer-mode-map [menu-bar mime-view]
  795.          (cons mime-viewer/menu-title
  796.            (make-sparse-keymap mime-viewer/menu-title)))
  797.        (mapcar (function
  798.             (lambda (item)
  799.               (define-key mime/viewer-mode-map
  800.             (vector 'menu-bar 'mime-view (car item))
  801.             (cons (nth 1 item)(nth 2 item))
  802.             )
  803.               ))
  804.            (reverse mime-viewer/menu-list)
  805.            )
  806.        ))
  807.     (use-local-map mime/viewer-mode-map)
  808.     (run-hooks 'mime-viewer/define-keymap-hook)
  809.     ))
  810.  
  811. (defun mime/viewer-mode (&optional mother ctl encoding ibuf obuf
  812.                    mother-keymap)
  813.   "Major mode for viewing MIME message.
  814.  
  815. Here is a list of the standard keys for mime/viewer-mode.
  816.  
  817. key        feature
  818. ---        -------
  819.  
  820. u        Move to upper content
  821. p or M-TAB    Move to previous content
  822. n or TAB    Move to next content
  823. SPC        Scroll up or move to next content
  824. M-SPC or DEL    Scroll down or move to previous content
  825. RET        Move to next line
  826. M-RET        Move to previous line
  827. v        Decode current content as `play mode'
  828. e        Decode current content as `extract mode'
  829. C-c C-p        Decode current content as `print mode'
  830. a        Followup to current content.
  831. x        Display X-Face
  832. q        Quit
  833. button-2    Move to point under the mouse cursor
  834.             and decode current content as `play mode'
  835. "
  836.   (interactive)
  837.   (let ((buf (get-buffer mime/output-buffer-name)))
  838.     (if buf
  839.     (save-excursion
  840.       (set-buffer buf)
  841.       (erase-buffer)
  842.       )))
  843.   (let ((ret (mime-viewer/setup-buffer ctl encoding ibuf obuf))
  844.     (win-conf (current-window-configuration))
  845.     )
  846.     (prog1
  847.     (switch-to-buffer (car ret))
  848.       (setq mime::preview/original-window-configuration win-conf)
  849.       (if mother
  850.       (progn
  851.         (setq mime::preview/mother-buffer mother)
  852.         ))
  853.       (mime-viewer/define-keymap mother-keymap)
  854.       (setq mime::preview/content-list (nth 1 ret))
  855.       (goto-char
  856.        (let ((ce (mime::preview-content-info/point-max
  857.           (car mime::preview/content-list)
  858.           ))
  859.          e)
  860.      (goto-char (point-min))
  861.      (search-forward "\n\n" nil t)
  862.      (setq e (match-end 0))
  863.      (if (<= e ce)
  864.          e
  865.        ce)))
  866.       (run-hooks 'mime/viewer-mode-hook)
  867.       )))
  868.  
  869. (defun mime-preview/point-content-number (point)
  870.   (save-window-excursion
  871.     (let ((pc (mime-preview/point-pcinfo (point)))
  872.       cinfo)
  873.       (switch-to-buffer (mime::preview-content-info/buffer pc))
  874.       (setq cinfo (mime::preview-content-info/content-info pc))
  875.       (mime-article/point-content-number (mime::content-info/point-min cinfo))
  876.       )))
  877.  
  878. (defun mime-preview/cinfo-to-pcinfo (cinfo)
  879.   (let ((rpcl mime::preview/content-list) cell)
  880.     (catch 'tag
  881.       (while rpcl
  882.     (setq cell (car rpcl))
  883.     (if (eq cinfo (mime::preview-content-info/content-info cell))
  884.         (throw 'tag cell)
  885.       )
  886.     (setq rpcl (cdr rpcl))
  887.     ))))
  888.  
  889. (autoload 'mime-preview/decode-content "tm-play")
  890.  
  891. (defvar mime-viewer/decoding-mode "play" "MIME body decoding mode")
  892.  
  893. (defun mime-viewer/play-content ()
  894.   (interactive)
  895.   (let ((mime-viewer/decoding-mode "play"))
  896.     (mime-preview/decode-content)
  897.     ))
  898.  
  899. (defun mime-viewer/extract-content ()
  900.   (interactive)
  901.   (let ((mime-viewer/decoding-mode "extract"))
  902.     (mime-preview/decode-content)
  903.     ))
  904.  
  905. (defun mime-viewer/print-content ()
  906.   (interactive)
  907.   (let ((mime-viewer/decoding-mode "print"))
  908.     (mime-preview/decode-content)
  909.     ))
  910.  
  911. (defun mime-viewer/follow-content ()
  912.   (interactive)
  913.   (let ((root-cinfo
  914.      (mime::preview-content-info/content-info
  915.       (car mime::preview/content-list)))
  916.     pc p-beg p-end cinfo rcnum)
  917.     (let ((rest mime::preview/content-list)
  918.       b e cell len rc)
  919.       (if (catch 'tag
  920.         (while (setq cell (car rest))
  921.           (setq b (mime::preview-content-info/point-min cell)
  922.             e (mime::preview-content-info/point-max cell))
  923.           (setq rest (cdr rest))
  924.           (if (and (<= b (point))(<= (point) e))
  925.           (throw 'tag cell)
  926.         )
  927.           ))
  928.       (progn
  929.         (setq pc cell
  930.           cinfo (mime::preview-content-info/content-info pc)
  931.           rcnum (mime::content-info/rcnum cinfo))
  932.         (setq len (length rcnum))
  933.         (setq p-beg (mime::preview-content-info/point-min pc)
  934.           p-end (mime::preview-content-info/point-max pc))
  935.         (while (and (setq cell (car rest))
  936.             (progn
  937.               (setq rc
  938.                 (mime::content-info/rcnum
  939.                  (mime::preview-content-info/content-info
  940.                   cell)))
  941.               (equal rcnum
  942.                  (nthcdr (- (length rc) len) rc))
  943.               ))
  944.           (setq p-end (mime::preview-content-info/point-max cell))
  945.           (setq rest (cdr rest))
  946.           ))))
  947.     (if pc
  948.     (let* ((mode (mime-preview/get-original-major-mode))
  949.            (new-name (format "%s-%s" (buffer-name) (reverse rcnum)))
  950.            new-buf
  951.            (the-buf (current-buffer))
  952.            (a-buf mime::preview/article-buffer)
  953.            (hb (mime::content-info/point-min cinfo))
  954.            (he (mime::content-info/point-max cinfo))
  955.            fields from to cc reply-to subj mid f)
  956.       (save-excursion
  957.         (set-buffer (setq new-buf (get-buffer-create new-name)))
  958.         (erase-buffer)
  959.         (insert-buffer-substring the-buf p-beg p-end)
  960.         (goto-char (point-min))
  961.         (if (mime-viewer/header-visible-p rcnum root-cinfo)
  962.         (delete-region (goto-char (point-min))
  963.                    (if (re-search-forward "^$" nil t)
  964.                    (match-end 0)
  965.                  (point-min)))
  966.           )
  967.         (goto-char (point-min))
  968.         (insert "\n")
  969.         (goto-char (point-min))
  970.         (let ((rcnum (mime::content-info/rcnum cinfo)) ci str)
  971.           (while (progn
  972.                (setq str
  973.                  (save-excursion
  974.                    (set-buffer a-buf)
  975.                    (setq ci (mime-article/rcnum-to-cinfo rcnum))
  976.                    (save-restriction
  977.                  (narrow-to-region
  978.                   (mime::content-info/point-min ci)
  979.                   (mime::content-info/point-max ci)
  980.                   )
  981.                  (std11-header-string-except
  982.                   (concat "^"
  983.                       (apply (function regexp-or) fields)
  984.                       ":") ""))))
  985.                (if (string-equal (mime::content-info/type ci)
  986.                      "message/rfc822")
  987.                nil
  988.              (if str
  989.                  (insert str)
  990.                )
  991.              rcnum))
  992.         (setq fields (std11-collect-field-names)
  993.               rcnum (cdr rcnum))
  994.         )
  995.           )
  996.         (let ((rest mime-viewer/following-required-fields-list))
  997.           (while rest
  998.         (let ((field-name (car rest)))
  999.           (or (std11-field-body field-name)
  1000.               (insert
  1001.                (format
  1002.             (concat field-name
  1003.                 ": "
  1004.                 (save-excursion
  1005.                   (set-buffer the-buf)
  1006.                   (set-buffer mime::preview/mother-buffer)
  1007.                   (set-buffer mime::preview/article-buffer)
  1008.                   (std11-field-body field-name)
  1009.                   )
  1010.                 "\n")))
  1011.               ))
  1012.         (setq rest (cdr rest))
  1013.         ))
  1014.         (mime/decode-message-header)
  1015.         )
  1016.       (let ((f (cdr (assq mode mime-viewer/following-method-alist))))
  1017.         (if (functionp f)
  1018.         (funcall f new-buf)
  1019.           (message
  1020.            (format
  1021.         "Sorry, following method for %s is not implemented yet."
  1022.         mode))
  1023.           ))
  1024.       ))))
  1025.  
  1026. (defun mime-viewer/display-x-face ()
  1027.   (interactive)
  1028.   (save-window-excursion
  1029.     (set-buffer mime::preview/article-buffer)
  1030.     (mime-viewer/x-face-function)
  1031.     ))
  1032.  
  1033. (defun mime-viewer/up-content ()
  1034.   (interactive)
  1035.   (let* ((pc (mime-preview/point-pcinfo (point)))
  1036.      (cinfo (mime::preview-content-info/content-info pc))
  1037.      (rcnum (mime::content-info/rcnum cinfo))
  1038.      )
  1039.     (if rcnum
  1040.     (let ((r (save-excursion
  1041.            (set-buffer (mime::preview-content-info/buffer pc))
  1042.                    (mime-article/rcnum-to-cinfo (cdr rcnum))
  1043.            ))
  1044.           (rpcl mime::preview/content-list)
  1045.           cell)
  1046.       (while (and
  1047.           (setq cell (car rpcl))
  1048.           (not (eq r (mime::preview-content-info/content-info cell)))
  1049.           )
  1050.         (setq rpcl (cdr rpcl))
  1051.         )
  1052.       (goto-char (mime::preview-content-info/point-min cell))
  1053.       )
  1054.       (mime-viewer/quit)
  1055.       )))
  1056.  
  1057. (defun mime-viewer/previous-content ()
  1058.   (interactive)
  1059.   (let* ((pcl mime::preview/content-list)
  1060.      (p (point))
  1061.      (i (- (length pcl) 1))
  1062.      beg)
  1063.     (catch 'tag
  1064.       (while (> i 0)
  1065.     (setq beg (mime::preview-content-info/point-min (nth i pcl)))
  1066.     (if (> p beg)
  1067.         (throw 'tag (goto-char beg))
  1068.       )
  1069.     (setq i (- i 1))
  1070.     )
  1071.       (let ((f (assq mime::preview/original-major-mode
  1072.              mime-viewer/over-to-previous-method-alist)))
  1073.     (if f
  1074.         (funcall (cdr f))
  1075.       ))
  1076.       )
  1077.     ))
  1078.  
  1079. (defun mime-viewer/next-content ()
  1080.   (interactive)
  1081.   (let ((pcl mime::preview/content-list)
  1082.     (p (point))
  1083.     beg)
  1084.     (catch 'tag
  1085.       (while pcl
  1086.     (setq beg (mime::preview-content-info/point-min (car pcl)))
  1087.     (if (< p beg)
  1088.         (throw 'tag (goto-char beg))
  1089.       )
  1090.     (setq pcl (cdr pcl))
  1091.     )
  1092.       (let ((f (assq mime::preview/original-major-mode
  1093.              mime-viewer/over-to-next-method-alist)))
  1094.     (if f
  1095.         (funcall (cdr f))
  1096.       ))
  1097.       )
  1098.     ))
  1099.  
  1100. (defun mime-viewer/scroll-up-content (&optional h)
  1101.   (interactive)
  1102.   (or h
  1103.       (setq h (- (window-height) 1))
  1104.       )
  1105.   (if (= (point) (point-max))
  1106.       (let ((f (assq mime::preview/original-major-mode
  1107.                      mime-viewer/over-to-next-method-alist)))
  1108.         (if f
  1109.             (funcall (cdr f))
  1110.           ))
  1111.     (let ((pcl mime::preview/content-list)
  1112.           (p (point))
  1113.           np beg)
  1114.       (setq np
  1115.             (or (catch 'tag
  1116.                   (while pcl
  1117.                     (setq beg (mime::preview-content-info/point-min (car pcl)))
  1118.                     (if (< p beg)
  1119.                         (throw 'tag beg)
  1120.                       )
  1121.                     (setq pcl (cdr pcl))
  1122.                     ))
  1123.                 (point-max)))
  1124.       (forward-line h)
  1125.       (if (> (point) np)
  1126.           (goto-char np)
  1127.         )
  1128.       ;;(show-subtree)
  1129.       ))
  1130.   )
  1131.  
  1132. (defun mime-viewer/scroll-down-content (&optional h)
  1133.   (interactive)
  1134.   (or h
  1135.       (setq h (- (window-height) 1))
  1136.       )
  1137.   (if (= (point) (point-min))
  1138.       (let ((f (assq mime::preview/original-major-mode
  1139.                      mime-viewer/over-to-previous-method-alist)))
  1140.         (if f
  1141.             (funcall (cdr f))
  1142.           ))
  1143.     (let ((pcl mime::preview/content-list)
  1144.           (p (point))
  1145.           pp beg)
  1146.       (setq pp
  1147.             (or (let ((i (- (length pcl) 1)))
  1148.                   (catch 'tag
  1149.                     (while (> i 0)
  1150.                       (setq beg (mime::preview-content-info/point-min
  1151.                                  (nth i pcl)))
  1152.                       (if (> p beg)
  1153.                           (throw 'tag beg)
  1154.                         )
  1155.                       (setq i (- i 1))
  1156.                       )))
  1157.                 (point-min)))
  1158.       (forward-line (- h))
  1159.       (if (< (point) pp)
  1160.           (goto-char pp)
  1161.         )))
  1162.   )
  1163.  
  1164. (defun mime-viewer/next-line-content ()
  1165.   (interactive)
  1166.   (mime-viewer/scroll-up-content 1)
  1167.   )
  1168.  
  1169. (defun mime-viewer/previous-line-content ()
  1170.   (interactive)
  1171.   (mime-viewer/scroll-down-content 1)
  1172.   )
  1173.  
  1174. (defun mime-viewer/quit ()
  1175.   (interactive)
  1176.   (let ((r (save-excursion
  1177.          (set-buffer (mime::preview-content-info/buffer
  1178.               (mime-preview/point-pcinfo (point))))
  1179.          (assq major-mode mime-viewer/quitting-method-alist)
  1180.          )))
  1181.     (if r
  1182.     (funcall (cdr r))
  1183.       )))
  1184.  
  1185. (defun mime-viewer/show-summary ()
  1186.   (interactive)
  1187.   (let ((r (save-excursion
  1188.          (set-buffer
  1189.           (mime::preview-content-info/buffer
  1190.            (mime-preview/point-pcinfo (point)))
  1191.           )
  1192.          (assq major-mode mime-viewer/show-summary-method)
  1193.          )))
  1194.     (if r
  1195.     (funcall (cdr r))
  1196.       )))
  1197.  
  1198. (defun mime-viewer/kill-buffer ()
  1199.   (interactive)
  1200.   (kill-buffer (current-buffer))
  1201.   )
  1202.  
  1203.  
  1204. ;;; @ end
  1205. ;;;
  1206.  
  1207. (provide 'tm-view)
  1208.  
  1209. (run-hooks 'tm-view-load-hook)
  1210.  
  1211. ;;; tm-view.el ends here
  1212.